Option Strict Off
Option Explicit On
Friend Class cGdiPlus
	
	' http://www.syix.com/wpsjr1/index.html
	' Class for GDI+ Access
	' Requires my gdi+.tlb
	
	' Note: if you are unfamiliar with tlb (type library)
	' They are files containing Declares, Enums and Constants (and can also contain interfaces and other data structures)
	' Type Libraries are compiled into the exe, and do NOT need to be available externally.
	
	' Feel free to use my tlb, with the stipulation that you will
	' name your first born male child after me. :P
	
	'UPGRADE_NOTE: Error was upgraded to Error_Renamed. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="A9E4979A-37FA-4718-9994-97DD76ED70A7"'
	Event Error_Renamed(ByVal lGdiError As Integer, ByVal sErrorDesc As String)
	
	Dim m_lToken As Integer ' Startup/Shutdown token
    Dim tGuids() As GDIPlus.CLSID ' Array of GUIDs for codecs
	Dim colCodecs As Collection ' Search into codec index on file extension
	Dim m_lNumCodecs As Integer    
    Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, ByRef graphics As Long) As Long
    Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
    Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef lpInput As GDIPlus.GdiplusStartupInput, ByRef lpOutput As Object) As Long
    Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
    Private Declare Function GdipSetSmoothingMode Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mSmoothingMode As Long) As Long
    Private Declare Function GdipDeleteBrush Lib "GdiPlus.dll" (ByVal mBrush As Long) As Long
    Private Declare Function GdipCreateSolidFill Lib "GdiPlus.dll" (ByVal mColor As Long, ByRef mBrush As Long) As Long
    Private Declare Function GdipFillEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mBrush As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
    Private Declare Function GdipGetImageEncoders Lib "GdiPlus.dll" (ByVal numEncoders As Long, ByVal Size As Long, ByRef Encoders As Object) As Long
    Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As Long, ByVal clsidEncoder As Guid, ByVal encoderParams As Object) As Long
    Private Declare Function GdipGetImageEncodersSize Lib "GdiPlus.dll" (ByRef numEncoders As Long, ByRef nsize As Long) As Long
    Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, ByVal BITMAP As Long) As Long
    Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Object) As Long
    Public Declare Function CLSIDFromString Lib "ole32.dll" (ByVal lpszProgID As Long, ByVal pCLSID As Guid) As Long



    '

    'UPGRADE_NOTE: Class_Initialize was upgraded to Class_Initialize_Renamed. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="A9E4979A-37FA-4718-9994-97DD76ED70A7"'
	Private Sub Class_Initialize_Renamed()
		Dim gsi As GDIPlus.GdiplusStartupInput
		Dim lError As Integer
		
		gsi.GdiplusVersion = 1
		'UPGRADE_ISSUE: COM expression not supported: Module methods of COM objects. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="5D48BAC6-2CD4-45AD-B1CC-8E4A241CDB58"'
        lError = GdiplusStartup(m_lToken, gsi, 0)
		
		If Not lError Then
			EnumEncoders()
		Else
			RaiseEvent Error_Renamed(lError, GdiErrorString(lError))
		End If
	End Sub
	Public Sub New()
		MyBase.New()
		Class_Initialize_Renamed()
	End Sub
	
	'UPGRADE_NOTE: Class_Terminate was upgraded to Class_Terminate_Renamed. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="A9E4979A-37FA-4718-9994-97DD76ED70A7"'
	Private Sub Class_Terminate_Renamed()
		'UPGRADE_ISSUE: COM expression not supported: Module methods of COM objects. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="5D48BAC6-2CD4-45AD-B1CC-8E4A241CDB58"'
        If m_lToken Then GdiplusShutdown(m_lToken)
	End Sub
	Protected Overrides Sub Finalize()
		Class_Terminate_Renamed()
		MyBase.Finalize()
	End Sub
	
	Private Function EnumEncoders() As Integer
		Dim lNumEncoders As Integer
		Dim lEncoderSize As Integer
		Dim lError As Integer
		Dim b() As Byte
		Dim i As Integer
		Dim codecs() As GDIPlus.ImageCodecInfo
		
		'UPGRADE_ISSUE: COM expression not supported: Module methods of COM objects. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="5D48BAC6-2CD4-45AD-B1CC-8E4A241CDB58"'
        lError = GdipGetImageEncodersSize(lNumEncoders, lEncoderSize)
		If Not lError Then
			ReDim codecs(lNumEncoders - 1)
			ReDim b(lEncoderSize - 1)
			
			'UPGRADE_ISSUE: COM expression not supported: Module methods of COM objects. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="5D48BAC6-2CD4-45AD-B1CC-8E4A241CDB58"'
            lError = GdipGetImageEncoders(lNumEncoders, lEncoderSize, b(0))
			If Not lError Then
				'UPGRADE_ISSUE: LenB function is not supported. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="367764E5-F3F8-4E43-AC3E-7FE0B5E074E2"'
				'UPGRADE_WARNING: Couldn't resolve default property of object codecs(). Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"'
                RtlMoveMemory(codecs(0), b(0), lNumEncoders * Len(CObj(codecs(0))))
				ReDim tGuids(lNumEncoders - 1)
				m_lNumCodecs = lNumEncoders
				'UPGRADE_NOTE: Object colCodecs may not be destroyed until it is garbage collected. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="6E35BFF6-CD74-4B09-9689-3E1A43DF8969"'
				colCodecs = Nothing
				colCodecs = New Collection
				
				Do While lNumEncoders
					lNumEncoders = lNumEncoders - 1
					'UPGRADE_WARNING: Couldn't resolve default property of object tGuids(lNumEncoders). Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"'
                    tGuids(lNumEncoders) = codecs(lNumEncoders).CLSID
					ParseOnChar(StringFromPointerW(codecs(lNumEncoders).pwszFilenameExtension), ";", lNumEncoders)
				Loop 
			Else
				RaiseEvent Error_Renamed(lError, GdiErrorString(lError))
			End If
		Else
			RaiseEvent Error_Renamed(lError, GdiErrorString(lError))
		End If
	End Function
	
	' included instead of using Split() for the VB5 set :)
	Private Sub ParseOnChar(ByRef sIn As String, ByRef sChar As String, ByVal lGuidIndex As Integer)
		Dim lStartPosition As Integer
		Dim lFoundPosition As Integer
		Dim sItem As String
		
		lFoundPosition = InStr(sIn, sChar)
		lStartPosition = 1
		
		Do While lFoundPosition
			sItem = Mid(sIn, lStartPosition, lFoundPosition - lStartPosition)
			colCodecs.Add(lGuidIndex, sItem)
			lStartPosition = lFoundPosition + 1
			lFoundPosition = InStr(lStartPosition, sIn, sChar)
		Loop 
		
		sItem = Trim(Mid(sIn, lStartPosition))
		'UPGRADE_ISSUE: LenB function is not supported. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="367764E5-F3F8-4E43-AC3E-7FE0B5E074E2"'
        If Len(CObj(sItem)) Then colCodecs.Add(lGuidIndex, sItem)
	End Sub
	
	' do not compare this to a boolean
	'  returns -1 for not found, 0-positive GUID index for found
	Private Function ExtensionExists(ByRef sKey As String) As Integer
		On Error GoTo errorhandler
		ExtensionExists = True ' invalid index
		
		If Not colCodecs Is Nothing Then
			'UPGRADE_WARNING: Couldn't resolve default property of object colCodecs.Item(). Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"'
			ExtensionExists = colCodecs.Item(sKey)
		End If
		
		Exit Function
errorhandler: 
		' exit silently
	End Function
	
	Private Function StringToGuid(ByRef sGuid As String) As GDIPlus.CLSID
		'UPGRADE_ISSUE: COM expression not supported: Module methods of COM objects. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="5D48BAC6-2CD4-45AD-B1CC-8E4A241CDB58"'
        CLSIDFromString(sGuid, StringToGuid)
	End Function
	
	' saves the contents of a picturebox to a file
	' supports GIF/JPG/TIF/PNG and various others
	Public Function PictureBoxToFile(ByVal pic As System.Windows.Forms.PictureBox, ByRef sFilename As String, Optional ByRef lQuality As Integer = 85) As Integer
		Dim sExtension As String
		Dim bitmap As Integer
		Dim lError As Integer
		Dim params As GDIPlus.EncoderParameters
		Dim lQual As Integer
		Dim lIndex As Integer
		'UPGRADE_WARNING: Arrays in structure tguid may need to be initialized before they can be used. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="814DF224-76BD-4BB4-BFFB-EA359CB9FC48"'
		Dim tguid As GDIPlus.CLSID
		
		sExtension = GetExtension(sFilename)
		
		lIndex = ExtensionExists("*." & sExtension)
		If lIndex > -1 Then
			'UPGRADE_ISSUE: Picture property Picture.hPal was not upgraded. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="CC4C7EC0-C903-48FC-ACCC-81861D12DA4A"'
			'UPGRADE_ISSUE: Picture property Picture.Handle was not upgraded. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="CC4C7EC0-C903-48FC-ACCC-81861D12DA4A"'
			'UPGRADE_ISSUE: COM expression not supported: Module methods of COM objects. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="5D48BAC6-2CD4-45AD-B1CC-8E4A241CDB58"'
            Dim t As Graphics = pic.CreateGraphics                        
            lError = GdipCreateBitmapFromHBITMAP(pic.Image.Handle, pic.Image.Hpal, bitmap)
			If Not lError Then
				If (Asc(sExtension) And Not 32) = System.Windows.Forms.Keys.J Then ' lazy JPEG/JPG/JPE/JFIF checking :P
					lQual = lQuality
					params.Count = 1
					'UPGRADE_WARNING: Couldn't resolve default property of object params.Parameter.CLSID. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"'
					params.Parameter.CLSID = StringToGuid(GDIPlus.GDIConsts.EncoderQuality)
					params.Parameter.NumberOfValues = 1
					params.Parameter.Type = GDIPlus.EncoderParameterValueType.EncoderParameterValueTypeLong
					'UPGRADE_ISSUE: VarPtr function is not supported. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="367764E5-F3F8-4E43-AC3E-7FE0B5E074E2"'
					params.Parameter.Value = VarPtr(lQual)
					'UPGRADE_ISSUE: COM expression not supported: Module methods of COM objects. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="5D48BAC6-2CD4-45AD-B1CC-8E4A241CDB58"'
                    lError = GdipSaveImageToFile(bitmap, sFilename, tGuids(lIndex), params)
				Else
					'UPGRADE_ISSUE: COM expression not supported: Module methods of COM objects. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="5D48BAC6-2CD4-45AD-B1CC-8E4A241CDB58"'
                    lError = GdipSaveImageToFile(bitmap, sFilename, tGuids(lIndex), 0)
				End If
				
				If Not lError Then
					PictureBoxToFile = True ' tada!
				Else
					RaiseEvent Error_Renamed(lError, GdiErrorString(lError))
				End If
			Else
				RaiseEvent Error_Renamed(lError, GdiErrorString(lError))
			End If
		End If
	End Function
	
	Private Function GetExtension(ByRef sFile As String) As String
		' by Donald, donald@xbeat.net, 20001010
		Dim iPos As Integer
		Dim iPosPrev As Integer
		
		Do  ' search last dot
			iPosPrev = iPos
			iPos = InStr(iPos + 1, sFile, ".")
		Loop While iPos
		
		If iPosPrev Then
			If InStr(iPosPrev + 1, sFile, "\") = 0 Then ' must be right of last backslash
				GetExtension = Mid(sFile, iPosPrev + 1)
			End If
		End If
	End Function
	
	Private Function StringFromPointerW(ByVal lPointer As Integer) As String
		Dim lLength As Integer
		
		If lPointer Then
			'UPGRADE_ISSUE: COM expression not supported: Module methods of COM objects. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="5D48BAC6-2CD4-45AD-B1CC-8E4A241CDB58"'
            lLength = lstrlenW(lPointer)
			StringFromPointerW = Space(lLength)
			'UPGRADE_ISSUE: StrPtr function is not supported. Click for more: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="367764E5-F3F8-4E43-AC3E-7FE0B5E074E2"'
            RtlMoveMemory(VarPtr(StringFromPointerW), lPointer, lLength * 2)
		End If
	End Function
	
	Public Function GdiErrorString(ByVal lError As GDIPlus.Status) As String
		Dim s As String
		
		Select Case lError
			Case GDIPlus.Status.GenericError : s = "Generic Error"
			Case GDIPlus.Status.InvalidParameter : s = "Invalid Parameter"
			Case GDIPlus.Status.OutOfMemory : s = "Out Of Memory"
			Case GDIPlus.Status.ObjectBusy : s = "Object Busy"
			Case GDIPlus.Status.InsufficientBuffer : s = "Insufficient Buffer"
			Case GDIPlus.Status.NotImplemented : s = "Not Implemented"
			Case GDIPlus.Status.Win32Error : s = "Win32 Error"
			Case GDIPlus.Status.WrongState : s = "Wrong State"
			Case GDIPlus.Status.Aborted : s = "Aborted"
			Case GDIPlus.Status.FileNotFound : s = "File Not Found"
			Case GDIPlus.Status.ValueOverflow : s = "Value Overflow"
			Case GDIPlus.Status.AccessDenied : s = "Access Denied"
			Case GDIPlus.Status.UnknownImageFormat : s = "Unknown Image Format"
			Case GDIPlus.Status.FontFamilyNotFound : s = "FontFamily Not Found"
			Case GDIPlus.Status.FontStyleNotFound : s = "FontStyle Not Found"
			Case GDIPlus.Status.NotTrueTypeFont : s = "Not TrueType Font"
			Case GDIPlus.Status.UnsupportedGdiplusVersion : s = "Unsupported Gdiplus Version"
			Case GDIPlus.Status.GdiplusNotInitialized : s = "Gdiplus Not Initialized"
			Case GDIPlus.Status.PropertyNotFound : s = "Property Not Found"
			Case GDIPlus.Status.PropertyNotSupported : s = "Property Not Supported"
			Case Else : s = "Unknown GDI+ Error"
		End Select
		
		GdiErrorString = s
	End Function
End Class